home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / cmpnew / cmpblock.lsp < prev    next >
Lisp/Scheme  |  1987-06-03  |  5KB  |  153 lines
  1. ;;; CMPBLOCK  Block and Return-from.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'compiler)
  8.  
  9. (si:putprop 'block 'c1block 'c1special)
  10. (si:putprop 'block 'c2block 'c2)
  11.  
  12. (si:putprop 'return-from 'c1return-from 'c1special)
  13. (si:putprop 'return-from 'c2return-from 'c2)
  14.  
  15. (defstruct blk
  16.            name            ;;; Block name.
  17.            ref            ;;; Referenced or not.  T or NIL.
  18.            ref-clb        ;;; Cross local function reference.
  19.                        ;;; During Pass1, T or NIL.
  20.                        ;;; During Pass2, the vs-address for the
  21.                        ;;; block id, or NIL.
  22.            ref-ccb        ;;; Cross closure reference.
  23.                        ;;; During Pass1, T or NIL.
  24.                        ;;; During Pass2, the ccb-vs for the
  25.                        ;;; block id, or NIL.
  26.            exit            ;;; Where to return.  A label.
  27.            value-to-go        ;;; Where the value of the block to go.
  28.            var            ;;; The block name holder.  Used only in
  29.                        ;;; the error message.
  30.            )
  31.  
  32. (defvar *blocks* nil)
  33.  
  34. ;;; During Pass 1, *blocks* holds a list of blk objects and the symbols 'CB'
  35. ;;; (Closure Boundary) and 'LB' (Level Boundary).  'CB' will be pushed on
  36. ;;; *blocks* when the compiler begins to process a closure.  'LB' will be
  37. ;;; pushed on *blocks* when *level* is incremented.
  38.  
  39. (defun c1block (args)
  40.   (when (endp args) (too-few-args 'block 1 0))
  41.   (cmpck (not (symbolp (car args)))
  42.          "The block name ~s is not a symbol." (car args))
  43.   (let* ((blk (make-blk :name (car args) :ref nil :ref-ccb nil :ref-clb nil))
  44.          (*blocks* (cons blk *blocks*))
  45.          (body (c1progn (cdr args))))
  46.         (if (or (blk-ref-ccb blk) (blk-ref-clb blk) (blk-ref blk))
  47.             (list 'block (reset-info-type (cadr body)) blk body)
  48.             body))
  49.   )
  50.  
  51. (defun c2block (blk body)
  52.   (cond ((blk-ref-ccb blk) (c2block-ccb blk body))
  53.         ((blk-ref-clb blk) (c2block-clb blk body))
  54.         (t (c2block-local blk body))))
  55.  
  56. (defun c2block-local (blk body)
  57.   (setf (blk-exit blk) *exit*)
  58.   (setf (blk-value-to-go blk) *value-to-go*)
  59.   (c2expr body)
  60.   )
  61.  
  62. (defun c2block-clb (blk body &aux (*vs* *vs*))
  63.   (setf (blk-exit blk) *exit*)
  64.   (setf (blk-value-to-go blk) *value-to-go*)
  65.   (setf (blk-ref-clb blk) (vs-push))
  66.   (wt-nl)
  67.   (wt-vs (blk-ref-clb blk))
  68.   (wt "=alloc_frame_id();")
  69.   (wt-nl "frs_push(FRS_CATCH,") (wt-vs (blk-ref-clb blk)) (wt ");")
  70.   (wt-nl "if(nlj_active)")
  71.   (wt-nl "{nlj_active=FALSE;frs_pop();")
  72.   (unwind-exit 'fun-val 'jump)
  73.   (wt "}")
  74.   (wt-nl "else{")
  75.   (let ((*unwind-exit* (cons 'frame *unwind-exit*))) (c2expr body))
  76.   (wt-nl "}")
  77.   )
  78.  
  79. (defun c2block-ccb (blk body &aux (*vs* *vs*) (*clink* *clink*)
  80.                                   (*ccb-vs* *ccb-vs*))
  81.   (setf (blk-exit blk) *exit*)
  82.   (setf (blk-value-to-go blk) *value-to-go*)
  83.   (setf (blk-ref-clb blk) (vs-push))
  84.   (setf (blk-var blk) (add-symbol (blk-name blk)))
  85.   (wt-nl) (wt-vs (blk-ref-clb blk)) (wt "=alloc_frame_id();")
  86.   (wt-nl) (wt-vs (blk-ref-clb blk))
  87.   (wt "=MMcons(") (wt-vs (blk-ref-clb blk)) (wt ",") (wt-clink) (wt ");")
  88.   (clink (blk-ref-clb blk))
  89.   (setf (blk-ref-ccb blk) (ccb-vs-push))
  90.   (wt-nl "frs_push(FRS_CATCH,") (wt-vs* (blk-ref-clb blk)) (wt ");")
  91.   (wt-nl "if(nlj_active)")
  92.   (wt-nl "{nlj_active=FALSE;frs_pop();")
  93.   (unwind-exit 'fun-val 'jump)
  94.   (wt "}")
  95.   (wt-nl "else{")
  96.   (let ((*unwind-exit* (cons 'frame *unwind-exit*))) (c2expr body))
  97.   (wt-nl "}")
  98.   )
  99.  
  100. (defun c1return-from (args)
  101.   (cond ((endp args) (too-few-args 'return-from 1 0))
  102.         ((and (not (endp (cdr args))) (not (endp (cddr args))))
  103.          (too-many-args 'return-from 2 (length args)))
  104.         ((not (symbolp (car args)))
  105.          "The block name ~s is not a symbol." (car args)))
  106.   (do ((blks *blocks* (cdr blks))
  107.        (name (car args))
  108.        (ccb nil) (clb nil))
  109.       ((endp blks)
  110.        (cmperr "The block ~s is undefined." name))
  111.       (declare (object name ccb clb))
  112.       (case (car blks)
  113.             (cb (setq ccb t))
  114.             (lb (setq clb t))
  115.             (t (when (eq (blk-name (car blks)) name)
  116.                      (let ((val (c1expr (cadr args)))
  117.                            (blk (car blks)))
  118.                           (cond
  119.                            (ccb (setf (blk-ref-ccb blk) t))
  120.                            (clb (setf (blk-ref-clb blk) t))
  121.                            (t (setf (blk-ref blk) t)))
  122.                           (return (list 'return-from
  123.                                         (reset-info-type (cadr val))
  124.                                         blk clb ccb val)))))))
  125.   )
  126.  
  127. (defun c2return-from (blk clb ccb val)
  128.   (cond (ccb (c2return-ccb blk val))
  129.         (clb (c2return-clb blk val))
  130.         (t (c2return-local blk val))))
  131.  
  132. (defun c2return-local (blk val)
  133.   (let ((*value-to-go* (blk-value-to-go blk))
  134.         (*exit* (blk-exit blk)))
  135.        (c2expr val))
  136.   )
  137.  
  138. (defun c2return-clb (blk val)
  139.   (let ((*value-to-go* 'top)) (c2expr* val))
  140.   (wt-nl "unwind(frs_sch(")
  141.   (if (blk-ref-ccb blk) (wt-vs* (blk-ref-clb blk)) (wt-vs (blk-ref-clb blk)))
  142.   (wt "),Cnil);")
  143.   )
  144.  
  145. (defun c2return-ccb (blk val)
  146.   (wt-nl "{frame_ptr fr;")
  147.   (wt-nl "fr=frs_sch(") (wt-ccb-vs (blk-ref-ccb blk)) (wt ");")
  148.   (wt-nl "if(fr==NULL) FEerror(\"The block ~s is missing.\",1,VV["
  149.          (blk-var blk) "]);")
  150.   (let ((*value-to-go* 'top)) (c2expr* val))
  151.   (wt-nl "unwind(fr,Cnil);}")
  152.   )
  153.